functor X86ToAssem (S : X86_TO_ASSEM_STRUCTS) : X86_TO_ASSEM =
struct
  open S
  
  structure A = Assem
  structure X = X86Assem
  
  structure E = AsmErrorMsg
  val error = E.error
  val errorMsg = "assembly syntax error\n"
		
  fun trReg reg =
      case reg
       of X.Eax => A.Eax
        | X.Ebx => A.Ebx
        | X.Ecx => A.Ecx
        | X.Edx => A.Edx
        | X.Edi => A.Edi
        | X.Esi => A.Esi
        | X.Ebp => A.Ebp
        | X.Esp => A.Esp
		   
  fun trEtype etype =
      case etype
       of X.Int => A.Int
        | X.Ptr ty => A.Ptr (trEtype ty)
        | X.Str s => A.Str s
        | X.Wild => A.Wild
		    
  val instrs : A.instr list ref = ref []
				  
  fun enterI instr = (instrs := instr::(!instrs))
  fun flushI () = (instrs:=[])
		  
  val blocks : (A.code4ptr) list ref = ref []
				       
  fun enterB (s, p) = (blocks := ((A.setCb4p(s, List.rev (!instrs), p)) :: !blocks); flushI ())
  fun flushB () = (blocks := [])
		  
  fun mk (instrs, l, prop) =
      case instrs
       of [] => error 0 errorMsg
        | (x as A.Jg _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock  xs1)
        | (x as A.Je _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock xs1)
        | (x as A.Jge _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock xs1)
        | (x as A.Jmp _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock xs1)
        | (x as A.Call _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock xs1)
        | (x as A.Ret _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock xs1)
        | (x as A.Malloc _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock xs1)
        | (x as A.Label _) :: xs1 => error 0 errorMsg
        | x :: xs1 => (enterI x; mk (xs1, l, prop))
       
  and mkBlock instrs =
      case instrs 
       of [] => ()
        | A.Label (l, prop) :: xs =>
          (case xs
            of [] => error 0 errorMsg
             | (x as A.Jg _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock xs1)
             | (x as A.Je _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock  xs1)
             | (x as A.Jge _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock xs1)
             | (x as A.Jmp _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock xs1)
             | (x as A.Call _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock xs1)
             | (x as A.Ret _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock xs1)
             | (x as A.Malloc _) :: xs1 => (enterI x; enterB (l, A.getLabPasst prop); mkBlock xs1)
             | (x as A.Label (_, _)) :: xs1 => error 0 errorMsg
             | x :: xs1 => (enterI x; mk (xs1, l, prop)))
        | _ => error 0 errorMsg 
		     
  and trInstrs instrs =
      case instrs
       of [] => []
        | X.Addr (r1, r2, pos) :: xs => A.Addr (trReg r1, trReg r2) :: (trInstrs xs)
        | X.Addz (i1, r, pos) :: xs => A.Addz (i1, trReg r) :: (trInstrs xs)
        | X.Addm (i1, r1, r2, pos) :: xs => A.Addm (i1, trReg r1, trReg r2) :: (trInstrs xs)
        | X.Subr (r1, r2, pos) :: xs => A.Subr (trReg r1, trReg r2) :: (trInstrs xs)
        | X.Subz (i, r, pos) :: xs => 
	  (case xs
	    of [] => A.Subz (i, trReg r) :: (trInstrs xs)
	     | [_] => A.Subz (i, trReg r) :: (trInstrs xs)
	     | X.Call (l1, l2, pos) :: X.Addz (i1, r1, pos1) :: xs1 => trInstrs (X.Call (l1, l2, pos) ::  xs1)
	     | _ => A.Subz (i, trReg r) :: (trInstrs xs))
        | X.Subm (i1, r1, r2, pos) :: xs => A.Subm (i1, trReg r1, trReg r2) :: (trInstrs xs)
        | X.Mulr (r1, r2, pos) :: xs => A.Mulr (trReg r1, trReg r2) :: (trInstrs xs)
        | X.Mulz (i, r, pos) :: xs => A.Mulz (i, trReg r) :: (trInstrs xs)
        | X.Mulm (i, r1, r2, pos) :: xs => A.Mulm (i, trReg r1, trReg r2) :: (trInstrs xs)
        | X.Div (r, pos) :: xs => (error pos errorMsg; [])
        | X.Cltd pos :: xs => 
          (case xs
            of [] => (error pos errorMsg; [])
             | X.Div (r, pos) :: xs1 => A.Div (trReg r) :: (trInstrs xs1)
             | _ => (error pos errorMsg; []))
        | X.Movld (i, r1, r2, pos) :: xs => A.Movld (i, trReg r1, trReg r2) :: (trInstrs xs)
        | X.Movr (r1, r2, pos) :: xs => A.Movr (trReg r1, trReg r2) :: (trInstrs xs)
        | X.Movst (r1, i1, r2, pos) :: xs => A.Movst (trReg r1, i1, trReg r2) :: (trInstrs xs)
        | X.Movz (i, r, ty, pos) :: xs =>
          (case xs
            of [] => A.Movz (i, trReg r, trEtype ty) :: (trInstrs xs)
             | [_] => A.Movz (i, trReg r, trEtype ty) :: (trInstrs xs)
             | [_, _] => A.Movz (i, trReg r, trEtype ty) :: (trInstrs xs)
             | [_, _, _] => A.Movz (i, trReg r, trEtype ty) :: (trInstrs xs)
             | X.Push (r1, pos1) :: X.CallMalloc (ty, _)
                   :: X.Addz (i2, X.Esp, pos2) :: X.Label (l, prop, pos3) :: xs1 => 
               A.Malloc (i div 4, l, trEtype ty) :: (trInstrs (X.Label (l, prop, pos3) :: xs1))
             | _ => A.Movz (i, trReg r, trEtype ty) :: (trInstrs xs))
        | X.Xchg (r1, r2, pos) :: xs => A.Xchg (trReg r1, trReg r2) :: (trInstrs xs)
        | X.Leab (i, r1, r2, pos) :: xs => A.Leab (i, trReg r1, trReg r2) :: (trInstrs xs)
        | X.Leal (lab, r, pos) :: xs => A.Leal (lab, trReg r)  :: (trInstrs xs)
        | X.Cmpr (r1, r2, pos) :: xs => A.Cmpr (trReg r1, trReg r2)  :: (trInstrs xs)
        | X.Cmpz (i, r, i1) :: xs => A.Cmpz (i, trReg r) :: (trInstrs xs)
        | X.Pop (r, pos) :: xs => A.Pop (trReg r) :: (trInstrs xs)
        | X.Push (r, pos) :: xs => 
          (case xs
            of [] => (error pos errorMsg; [])
             | [_] => A.Push (trReg r) :: (trInstrs xs)
             | X.CallFree (_) :: X.Addz (i, X.Esp, pos2) :: xs1 => A.Free (trReg r) :: (trInstrs xs1)
             | _ => A.Push (trReg r) :: (trInstrs xs))
        | X.Leave pos :: xs => A.Leave  :: (trInstrs xs)
        | X.Jg (l1, l2, pos) :: xs =>
          (case xs
            of [] => (error pos errorMsg; [])
             | X.Label (s, prop, pos1) :: _ => A.Jg (l1, s) :: (trInstrs xs)
             | _ => (error pos errorMsg; []))
        | X.Je (l1, l2, pos) :: xs =>
          (case xs
            of [] => (error pos errorMsg; [])
             | X.Label (s, prop, pos1) :: _ => A.Je (l1, s) :: (trInstrs xs)
             | _ => (error pos errorMsg; []))
        | X.Jge (l1, l2, pos) :: xs =>
          (case xs
            of [] => (error pos errorMsg; [])
             | X.Label (s, prop, pos1) :: _ => A.Jge (l1, s) :: (trInstrs xs)
             | _ => (error pos errorMsg; []))
        | X.Jmp (l, pos) :: xs => A.Jmp l :: (trInstrs xs)
        | X.Call (l1, l2, pos) :: xs => 
          (case xs
            of [] => (error pos errorMsg; [])
             | X.Label (l, prop, pos) :: _ => A.Call (l1, l) :: (trInstrs xs)
             | _ => (error pos errorMsg; []))
        | X.Ret (l, pos) :: xs => A.Ret l :: (trInstrs xs)
        | X.Label (s, prop, pos) :: xs => 
          A.Label (s, A.newAsst (SOME (fn _ => fn _ => A.True, SOME (trPprop prop)))) :: (trInstrs xs)
        | X.Directive s :: xs => A.Directive s :: (trInstrs xs)
        | X.CallMalloc (ty, pos) :: xs => (error pos errorMsg; [])
        | (X.CallFree pos) :: xs => (error pos errorMsg; [])
       
  and trAptr aptr =
      case aptr 
       of X.Preg reg => A.Preg (trReg reg)
        | X.Pstk (i, reg) => A.Pstk (i, trReg reg)
        | X.Pmem (i, aptr1, pexp) => A.Pmem (i, trAptr aptr1, trPexp pexp)
        | X.Pgmem i => A.Pgmem i
        | X.Pid id => A.Pid id
       
  and trPexp pexp =
      case pexp
       of X.Pvar aptr => A.Pvar (trAptr aptr)
        | X.PintNum i => A.PintNum i
        | X.Pplus (pexp1, pexp2) => A.Pplus (trPexp pexp1, trPexp pexp2)
        | X.Pminus (pexp1, pexp2) => A.Pminus (trPexp pexp1, trPexp pexp2)
        | X.Ptimes (pexp1, pexp2) => A.Ptimes (trPexp pexp1, trPexp pexp2)
  
  and trN aptrs = List.map trAptr aptrs
  
  and trD aptrs = List.map trAptr aptrs
  
  and trPi aptrss = List.map trN aptrss
     
  and trPprop pprop =
      case pprop
       of X.Ptrue => A.Ptrue
        | X.Pnot p => A.Pnot (trPprop p)
        | X.Pand (p1, p2) => A.Pand (trPprop p1, trPprop p2)
        | X.Por (p1, p2) => A.Por (trPprop p1, trPprop p2)
        | X.Pge (e1, e2) => A.Pge (trPexp e1, trPexp e2)
        | X.Pgt (e1, e2) => A.Pgt (trPexp e1, trPexp e2)
        | X.Plt (e1, e2) => A.Plt (trPexp e1, trPexp e2)
        | X.Ple (e1, e2) => A.Ple (trPexp e1, trPexp e2)
        | X.Peq (e1, e2) => A.Peq (trPexp e1, trPexp e2)
        | X.Pne (e1, e2) => A.Pne (trPexp e1, trPexp e2)
        | X.Pforall (s, ty, p) => A.Pforall ((s, trEtype ty), trPprop p)
        | X.Pex (s, ty, p) => A.Pex ((s, trEtype ty), trPprop p)
        | X.Pi aptrss => A.Pi (trPi aptrss)
        | X.N aptrs => A.N (trN aptrs)
        | X.D aptrs => A.D (trD aptrs)
        | X.Ptree e => A.Ptree (trPexp e)
        | X.Plist e => A.Plist (trPexp e)
        | X.Ppred (s, p) => A.Ppred (s, trPprop p)

  fun trDecs decs = 
      case decs
       of [] => []
        | (etype, aptr1, aptr2) :: xs =>
          (trAptr aptr1, trAptr aptr2, trEtype etype) :: (trDecs xs)
          
  fun trFunc func =
      case func
       of X.Func {decs,
                  pre,
                  post,
                  name,
                  instrs,
                  pos} =>
          let val _ = flushB ()
              val _ = mkBlock (trInstrs instrs)
              val b = List.rev (!blocks)
          in  A.setPprf (name, SOME (trPprop pre), SOME (trPprop post), b, trDecs decs)
          end
        
  fun trText textsec =
      case textsec
       of X.Text1 {funcs, 
                   pos} =>
          List.map trFunc funcs
  
  fun trFields f =
      case f
       of [] => []
        | (i, ty) :: xs => (i, trEtype ty) :: (trFields xs)
  
  fun mkSenv sdec =
      case sdec
       of SOME (X.Sdec {name,
                        fields,
                        pos}) =>
          [(name, trFields fields)]
        | NONE => []
        
  fun mkFrtenv funrettype =
      case funrettype
       of X.FunRetType {pairs, pos} =>
          let fun mk l =
                  case l
                   of [] => []
                    | (fname, ty) :: xs => (fname, trEtype ty) :: (mk xs)
          in  mk pairs
          end
        
  fun trProg prog =
      case prog
       of X.Prog {sdec,
                  funrettype,
                  textsec,
                  datasec,
                  pos} =>
          (trText textsec, A.setGinf (mkSenv sdec, [], mkFrtenv funrettype))
          
  fun x86ToAssem prog = trProg prog
end
